home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Caml Light 0.7 / examples / minicaml / types.ml < prev    next >
Text File  |  1995-06-01  |  5KB  |  143 lines
  1. type type_simple =
  2.     Variable of variable_de_type
  3.   | Terme of string * type_simple vect
  4.  
  5. and variable_de_type =
  6.   { mutable Niveau: int;
  7.     mutable Valeur: valeur_d'une_variable }
  8.  
  9. and valeur_d'une_variable =
  10.     Inconnue
  11.   | Connue of type_simple;;
  12.  
  13. type schéma_de_types =
  14.   { Paramètres: variable_de_type list;
  15.     Corps: type_simple };;
  16.  
  17. let type_int = Terme("int", [||])
  18. and type_bool = Terme("bool", [||])
  19. and type_flèche t1 t2 = Terme("->", [|t1; t2|])
  20. and type_produit t1 t2 = Terme("*", [|t1; t2|])
  21. and type_liste t = Terme("list", [|t|]);;
  22. let rec valeur_de = function
  23.     Variable({Valeur = Connue ty1} as var) ->
  24.       let valeur_de_ty1 = valeur_de ty1 in
  25.       var.Valeur <- Connue valeur_de_ty1;
  26.       valeur_de_ty1
  27.   | ty -> ty;;
  28. let test_d'occurrence var ty =
  29.   let rec test t =
  30.     match valeur_de t with
  31.       Variable var' ->
  32.         if var == var' then raise(Circularité(Variable var, ty))
  33.     | Terme(constructeur, arguments) ->
  34.         do_vect test arguments
  35.   in test ty;;
  36. let rec rectifie_niveaux niveau_max ty =
  37.   match valeur_de ty with
  38.     Variable var ->
  39.       if var.Niveau > niveau_max then var.Niveau <- niveau_max
  40.   | Terme(constructeur, arguments) ->
  41.       do_vect (rectifie_niveaux niveau_max) arguments;;
  42. let rec unifie ty1 ty2 =
  43.   let valeur1 = valeur_de ty1
  44.   and valeur2 = valeur_de ty2 in
  45.   if valeur1 == valeur2 then () else
  46.     match (valeur1, valeur2) with
  47.       Variable var, ty ->
  48.         test_d'occurrence var ty;
  49.         rectifie_niveaux var.Niveau ty;        
  50.         var.Valeur <- Connue ty
  51.     | ty, Variable var ->
  52.         test_d'occurrence var ty;
  53.         rectifie_niveaux var.Niveau ty;        
  54.         var.Valeur <- Connue ty
  55.     | Terme(constr1, arguments1), Terme(constr2, arguments2) ->
  56.         if constr1 <> constr2 then
  57.           raise (Conflit(valeur1, valeur2))
  58.         else
  59.           for i = 0 to vect_length arguments1 - 1 do
  60.             unifie arguments1.(i) arguments2.(i)
  61.           done;;
  62. let niveau_de_liaison = ref 0;;
  63.  
  64. let début_de_définition () = incr niveau_de_liaison
  65. and fin_de_définition () = decr niveau_de_liaison;;
  66.  
  67. let nouvelle_inconnue () =
  68.   Variable {Niveau = !niveau_de_liaison; Valeur = Inconnue};;
  69. let généralisation ty =
  70.   let paramètres = ref [] in
  71.   let rec trouve_paramètres ty =
  72.     match valeur_de ty with
  73.       Variable var ->
  74.         if var.Niveau > !niveau_de_liaison & not memq var !paramètres
  75.         then paramètres := var :: !paramètres
  76.     | Terme(constr, arguments) ->
  77.         do_vect trouve_paramètres arguments in
  78.   trouve_paramètres ty;
  79.   {Paramètres = !paramètres; Corps = ty};;
  80.  
  81. let schéma_trivial ty = {Paramètres = []; Corps = ty};;
  82. let spécialisation schéma =
  83.   match schéma.Paramètres with
  84.     [] -> schéma.Corps
  85.   | paramètres ->
  86.       let nouvelles_inconnues =
  87.         map (fun var -> (var, nouvelle_inconnue())) paramètres in
  88.       let rec copie ty =
  89.         match valeur_de ty with
  90.           Variable var as ty ->
  91.             begin try
  92.               assq var nouvelles_inconnues
  93.             with Not_found ->
  94.               ty
  95.             end
  96.         | Terme(constr, arguments) ->
  97.             Terme(constr, map_vect copie arguments) in
  98.       copie schéma.Corps;;
  99. let noms_des_variables = ref ([] : (variable_de_type * string) list)
  100. and compteur_de_variables = ref 0;;
  101.  
  102. let imprime_var var =
  103.   print_string "'";
  104.   try
  105.     print_string (assq var !noms_des_variables)
  106.   with Not_found ->
  107.     let nom =
  108.       make_string 1
  109.         (char_of_int(int_of_char `a` + !compteur_de_variables)) in
  110.     incr compteur_de_variables;
  111.     noms_des_variables := (var, nom) :: !noms_des_variables;
  112.     print_string nom;;
  113.  
  114. let rec imprime ty =
  115.   match valeur_de ty with
  116.     Variable var ->
  117.       imprime_var var
  118.   | Terme(constructeur, arguments) ->
  119.       match vect_length arguments with
  120.         0 -> print_string constructeur
  121.       | 1 -> imprime arguments.(0);
  122.              print_string " "; print_string constructeur
  123.       | 2 -> print_string "("; imprime arguments.(0);
  124.              print_string " "; print_string constructeur;
  125.              print_string " "; imprime arguments.(1);
  126.              print_string ")";;
  127.  
  128. let imprime_type ty =
  129.   noms_des_variables := [];
  130.   compteur_de_variables := 0;
  131.   imprime ty;;
  132.   
  133. let imprime_schéma schéma =
  134.   noms_des_variables := [];
  135.   compteur_de_variables := 0;
  136.   if schéma.Paramètres <> [] then begin
  137.     print_string "pour tout ";
  138.     do_list (fun var -> imprime_var var; print_string " ")
  139.             schéma.Paramètres;
  140.     print_string ", "
  141.   end;
  142.   imprime schéma.Corps;;
  143.